home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / textButton.tcl.z / textButton.tcl
Text File  |  2002-07-08  |  4KB  |  129 lines
  1. #
  2. # $Id: textButton.tcl,v 1.3 2000/02/02 19:33:58 valdis Exp $
  3. #
  4. # A text widget button that acts like a Button widget.
  5. # - John Robert LoVerso
  6. #
  7. proc TextButton_Init { {t {}} } {
  8.     global tkPriv
  9.  
  10.     set tkPriv(seed) 0
  11.     if {[winfo depth .] > 4} {
  12.     Preferences_Resource tkPriv(background)    c_uri thistle
  13.     Preferences_Resource tkPriv(foreground)    c_uriFg black
  14.     Preferences_Resource tkPriv(activebackground)    c_uriAbg white
  15.     Preferences_Resource tkPriv(activeforeground)    c_uriAfg black
  16.     } else {
  17.     Preferences_Resource tkPriv(background)    c_uri black
  18.     Preferences_Resource tkPriv(foreground)    c_uriFg white
  19.     Preferences_Resource tkPriv(activebackground)    c_uriAbg white
  20.     Preferences_Resource tkPriv(activeforeground)    c_uriAfg black
  21.     }
  22.     if {$t != {}} {
  23.     # Hack - we know tags with names hdrlook=* are preserved.
  24.     # These tags just serve to pre-allocate our colors
  25.     $t tag configure hdrlook=TextButton1 -foreground $tkPriv(foreground) \
  26.         -background $tkPriv(background)
  27.     $t tag configure hdrlook=TextButton2 \
  28.         -foreground $tkPriv(activeforeground) \
  29.         -background $tkPriv(activebackground)
  30.     }
  31. }
  32.  
  33. proc TextButton { w text cmd } {
  34.  
  35.     $w insert insert { }
  36.     set start [$w index insert]
  37.     $w insert insert $text
  38.     set end [$w index insert]
  39.     $w insert insert { }
  40.  
  41.     set tag [TextButtonRange $w $start $end $cmd]
  42. }
  43.  
  44. proc TextButtonRange { w start end cmd } {
  45.     global tkPriv
  46.  
  47.     incr tkPriv(seed)
  48.     set id tkPriv$tkPriv(seed)
  49.     $w tag add $id $start "$end +1 char"
  50.     $w tag bind $id <Any-Enter> [concat TextButtonEnter $w $id]
  51.     $w tag bind $id <Any-Leave> [concat TextButtonLeave $w $id]
  52.     $w tag bind $id <1> [concat TextButtonDown $w $id]
  53.     $w tag bind $id <ButtonRelease-1> [concat TextButtonUp $w $id [list $cmd]]
  54.     $w tag configure $id -relief raised -borderwidth 2 \
  55.          -background $tkPriv(background) -foreground $tkPriv(foreground)
  56.     return $id
  57. }
  58.  
  59. #
  60. #
  61. # from button.tcl --
  62. #
  63.  
  64. # The procedure below is invoked when the mouse pointer enters a
  65. # button widget.  It records the button we're in and changes the
  66. # state of the button to active unless the button is disabled.
  67.  
  68. proc TextButtonEnter {w id} {
  69.     global tkPriv
  70.     $w tag configure $id -background $tkPriv(activebackground) \
  71.             -foreground $tkPriv(activeforeground)
  72.     $w configure -cursor cross
  73.     set tkPriv(window) $w
  74.     set tkPriv(id) $id
  75. }
  76.  
  77. # The procedure below is invoked when the mouse pointer leaves a
  78. # button widget.  It changes the state of the button back to
  79. # inactive.
  80.  
  81. proc TextButtonLeave {w id} {
  82.     global tkPriv
  83.     #puts "Leave"
  84.     $w tag configure $id -background $tkPriv(background) \
  85.             -foreground $tkPriv(foreground)
  86.     $w configure -cursor [option get $w cursor Text ]
  87.     set tkPriv(window) ""
  88.     set tkPriv(id) ""
  89.     set tkPriv(cmd) ""
  90. }
  91.  
  92. # The procedure below is invoked when the mouse button is pressed in
  93. # a button/radiobutton/checkbutton widget.  It records information
  94. # (a) to indicate that the mouse is in the button, and
  95. # (b) to save the button's relief so it can be restored later.
  96.  
  97. proc TextButtonDown {w id} {
  98.     global tkPriv
  99.     set tkPriv(relief) [lindex [$w tag config $id -relief] 4]
  100.     set tkPriv(buttonWindow) $w
  101.     set tkPriv(buttonId) $id
  102.     $w tag configure $id -relief sunken
  103. }
  104.  
  105. # The procedure below is invoked when the mouse button is released
  106. # for a button/radiobutton/checkbutton widget.  It restores the
  107. # button's relief and invokes the command as long as the mouse
  108. # hasn't left the button.
  109.  
  110. proc TextButtonUp {w id {cmd {}}} {
  111.     global tkPriv
  112.     #puts "Up"
  113.     if {$w == $tkPriv(buttonWindow) && $id == $tkPriv(buttonId)} {
  114.     $w tag config $id -relief $tkPriv(relief)
  115.     if {$w == $tkPriv(window) && $id == $tkPriv(id)} {
  116.         set tkPriv(cmd) $cmd
  117.         #puts "Primed"
  118.         after 1 TextButtonActivate $w $id
  119.     }
  120.     set tkPriv(buttonWindow) ""
  121.     set tkPriv(buttonId) ""
  122.     }
  123. }
  124. proc TextButtonActivate {w id} {
  125.     global tkPriv
  126.     #puts "Activate cmd=$tkPriv(cmd)"
  127.     eval $tkPriv(cmd)
  128. }
  129.